home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 011-020 / amok11 / r.o.m. / m2sources / calcu.mod < prev    next >
Text File  |  1993-11-04  |  26KB  |  836 lines
  1. IMPLEMENTATION MODULE Calcu;
  2. (*
  3.   Created: 02/88
  4.   Changed: 08.02.88/03.03.88/25.7.88/5.8.88/11.9.88/21.9.88 by 
  5.              Stefan Salewski
  6.              Stolper Weg 3
  7.              2160 Stade   West-Germany
  8.              Tel: 04141/61130
  9.              
  10.   Note: compiled with AMIGA Modula-2 System by AMSoft version from 5.5.88
  11.   
  12. *)   
  13.   FROM ASCII IMPORT nul,lf,cr;
  14.   FROM Arts IMPORT Assert,Error,TermProcedure;
  15.   FROM SYSTEM IMPORT ADR,ADDRESS;
  16.   FROM Storage IMPORT ALLOCATE,DEALLOCATE;
  17.   IMPORT FileSystem;
  18.   FROM FileMessage IMPORT StrPtr,ResponseText;
  19.   FROM DOS IMPORT Open,Close,Write,newFile,FileHandlePtr;
  20.   FROM Conversions IMPORT StrToVal,ValToStr;
  21.   FROM MyMathLibLong IMPORT sqrt,unit,AngleUnit;
  22.   FROM MyRemember IMPORT RememberNodePtr;
  23.   FROM MakeMenu IMPORT MenuRecord,InitMenu,FreeMenu,MenuNum,ItemNum,SubNum;
  24.   FROM StringInOut IMPORT OpenNewWindow,CloseNewWindow,ReadString,WriteString,
  25.     SetClear,GetKey,inputOK,Flags,FlagSet;
  26.   FROM Formelauswertung IMPORT DefFormel,LongBerechnung,AssignLong,ClearVar,
  27.     GetLongValue;
  28.   FROM MyStrings IMPORT Assign,Length;
  29.   FROM FormelausFText IMPORT GetFehlertext;
  30.   FROM MyLongRealConversions IMPORT RealToStr,fillChar;
  31.   FROM Exec IMPORT WaitPort,GetMsg,ReplyMsg;
  32.   FROM Intuition IMPORT WindowPtr,IntuiMessagePtr,IDCMPFlags,IDCMPFlagSet,
  33.     ModifyIDCMP,SetMenuStrip,MenuPtr,MenuItemPtr,menuNull,ItemAddress,
  34.     GetPrefs,PreferencesPtr,ClearMenuStrip;
  35.     
  36.   CONST
  37.     MaxLongReal=MAX(LONGREAL);
  38.   TYPE
  39.     FString=ARRAY[0..250] OF CHAR;
  40.     Out=(s,p,d);
  41.     SPDSet=SET OF Out;
  42.   VAR
  43.     wP:WindowPtr;
  44.     fileOpen:BOOLEAN;
  45.     textFile:FileSystem.File;
  46.     rememberKey:RememberNodePtr;
  47.     mDefiniert:BOOLEAN;
  48.     oldm:LONGREAL;
  49.     
  50.   PROCEDURE CleanupTas;
  51.   BEGIN
  52.     IF wP#NIL THEN
  53.       ClearMenuStrip(wP);
  54.       CloseNewWindow(wP);
  55.       wP:=NIL;
  56.       IF NOT mDefiniert THEN
  57.         IF oldm= MaxLongReal THEN
  58.           ClearVar('m')
  59.         ELSE 
  60.           IF AssignLong('m',oldm) THEN END
  61.         END
  62.       END;
  63.     END;
  64.     IF fileOpen THEN
  65.       FileSystem.Close(textFile);
  66.       fileOpen:=FALSE;
  67.     END;
  68.     IF rememberKey#NIL THEN
  69.       FreeMenu(rememberKey);
  70.       rememberKey:=NIL
  71.     END;
  72.   END CleanupTas;
  73.   
  74.   PROCEDURE Tas;
  75.     CONST
  76.       MaxStellen=14;
  77.     VAR
  78.       tasMenu:ARRAY[0..3] OF MenuRecord;
  79.       firstMenu:MenuPtr;
  80.       ergebnis:LONGREAL;
  81.       myPref:RECORD
  82.                leftMargin:INTEGER;
  83.                rightMargin:INTEGER;
  84.              END;
  85.       outputSet:SPDSet;
  86.       fileName:ARRAY[0..32] OF CHAR;
  87.       expoSet,formelAnwenden:BOOLEAN;
  88.       datenzahl:CARDINAL;
  89.       outStellen:INTEGER;
  90.       summe,qSumme,mittelwert,standart,grundgesamt:LONGREAL;
  91.       ende,canDelete:BOOLEAN;
  92.       formel,alteFormel:FString;
  93.       prSpace:CHAR;
  94.       formelChar:CHAR;
  95.       printerSpace:ARRAY [0..255] OF CHAR;
  96.       oldFormel:BOOLEAN;
  97.       newBase,oldBase:[2..16];
  98.       allFix:BOOLEAN;
  99.       printOnlyResult:BOOLEAN;
  100.       fehler:CARDINAL;
  101.     PROCEDURE Init;
  102.       VAR
  103.         prefPtr:PreferencesPtr;
  104.         i:[0..255];
  105.     BEGIN
  106.       ALLOCATE(prefPtr,SIZE(prefPtr^));
  107.       GetPrefs(prefPtr,SIZE(prefPtr^));
  108.       (*myPref.paperLength:=prefPtr^.paperType;*)
  109.       myPref.leftMargin:=prefPtr^.printRightMargin;
  110.       myPref.rightMargin:=prefPtr^.printImage;
  111.      (* eigenwillige Preference-Bezeichnungen !!!!Compilerfehler!!!!!!!!!!!*)
  112.       DEALLOCATE(prefPtr,SIZE(prefPtr^));
  113.       prSpace:=' ';
  114.       FOR i:=0 TO 254 DO
  115.       printerSpace[i]:=prSpace;
  116.       END;
  117.       printerSpace[255]:=0C;
  118.       outputSet:=SPDSet{s};
  119.       fileName:='RechnerProtokoll';
  120.       fileOpen:=FALSE;
  121.       formel[0]:=0C;
  122.       alteFormel[0]:=0C;
  123.       fehler:=0;
  124.       ende:=FALSE;
  125.       oldFormel:=FALSE;
  126.       datenzahl:=0;
  127.       canDelete:=FALSE;
  128.       summe:=0.0;
  129.       qSumme:=0.0;
  130.       standart:=0.0;
  131.       grundgesamt:=0.0;
  132.       outStellen:=MaxStellen;
  133.       allFix:=TRUE;
  134.       oldBase:=16;
  135.       newBase:=16;
  136.       expoSet:=FALSE;
  137.       formelAnwenden:=FALSE;
  138.       mDefiniert:=FALSE;
  139.       unit:=rad;
  140.       printOnlyResult:=FALSE;
  141.     END Init;
  142.   (*************************************************************************)
  143.     PROCEDURE InitTasMenu():BOOLEAN;
  144.       VAR i,j:CARDINAL;
  145.     BEGIN
  146.       WITH tasMenu[0] DO
  147.         mname:='Aktionen';
  148.         anzahlItems:=4;
  149.         WITH mItems[0] DO
  150.           iname:='Letzte Formel';
  151.           commandKey:='F';
  152.           anzahlSubitems:=0;
  153.         END;
  154.         WITH mItems[1] DO
  155.           iname:='Wert speichern';
  156.           commandKey:='S';
  157.           anzahlSubitems:=0;
  158.         END;
  159.         WITH mItems[2] DO
  160.           iname:='Füllzeichen setzen';
  161.           commandKey:='.';
  162.           anzahlSubitems:=0;
  163.         END;
  164.         WITH mItems[3] DO
  165.           iname:='Ins Hauptmenü';
  166.           commandKey:='E';
  167.           anzahlSubitems:=0;
  168.         END;
  169.       END;
  170.       WITH tasMenu[1] DO
  171.         mname:='Parameter';
  172.         anzahlItems:=8;
  173.         WITH mItems[0] DO
  174.           iname:='Drucker';
  175.           anzahlSubitems:=2;
  176.           subrecords[0].subName:='Aus';
  177.           subrecords[0].commandKey:='A';
  178.           subrecords[1].subName:='Ein';
  179.           subrecords[1].commandKey:='P';
  180.         END;
  181.         WITH mItems[1] DO
  182.           iname:='Druckerausgabe';
  183.           anzahlSubitems:=2;
  184.           subrecords[0].subName:='2+3=5';
  185.           subrecords[0].commandKey:=0C;
  186.           subrecords[1].subName:='=5';
  187.           subrecords[1].commandKey:=0C;
  188.         END;
  189.         WITH mItems[2] DO
  190.           iname:='Disk-Protokoll';
  191.           anzahlSubitems:=2;
  192.           subrecords[0].subName:='Nein';
  193.           subrecords[0].commandKey:='N';
  194.           subrecords[1].subName:='Ja';
  195.           subrecords[1].commandKey:='J';
  196.         END;
  197.         WITH mItems[3] DO
  198.           iname:='Exponent';
  199.           anzahlSubitems:=2;
  200.           subrecords[0].subName:='Nein';
  201.           subrecords[0].commandKey:='[';
  202.           subrecords[1].subName:='Ja';
  203.           subrecords[1].commandKey:=']';
  204.         END;
  205.         WITH mItems[4] DO
  206.           iname:='Winkeleinheit';
  207.           anzahlSubitems:=3;
  208.           subrecords[0].subName:='Rad';
  209.           subrecords[0].commandKey:=0C;
  210.           subrecords[1].subName:='Deg';
  211.           subrecords[1].commandKey:=0C;
  212.           subrecords[2].subName:='Gon';
  213.           subrecords[2].commandKey:=0C;
  214.         END;
  215.         WITH mItems[5] DO
  216.           iname:='Formel anwenden';
  217.           anzahlSubitems:=2;
  218.           subrecords[0].subName:='Nein';
  219.           subrecords[0].commandKey:='z';
  220.           subrecords[1].subName:='Ja';
  221.           subrecords[1].commandKey:='y';
  222.         END;
  223.         WITH mItems[6] DO
  224.           iname:='Stellenbeschränkung';
  225.           anzahlSubitems:=2;
  226.           subrecords[0].subName:='Gesamt';
  227.           subrecords[0].commandKey:='G';
  228.           subrecords[1].subName:='Komma';
  229.           subrecords[1].commandKey:='K';
  230.         END;
  231.         WITH mItems[7] DO
  232.           iname:='Stellen';
  233.           anzahlSubitems:=12;
  234.           subrecords[0].subName:='14';
  235.           subrecords[0].commandKey:='\';
  236.           subrecords[1].subName:='12';
  237.           subrecords[1].commandKey:='-';
  238.           subrecords[2].subName:='10';
  239.           subrecords[2].commandKey:='9';
  240.           subrecords[3].subName:='8';
  241.           subrecords[3].commandKey:='8';
  242.           subrecords[4].subName:='7';
  243.           subrecords[4].commandKey:='7';
  244.           subrecords[5].subName:='6';
  245.           subrecords[5].commandKey:='6';
  246.           subrecords[6].subName:='5';
  247.           subrecords[6].commandKey:='5';
  248.           subrecords[7].subName:='4';
  249.           subrecords[7].commandKey:='4';
  250.           subrecords[8].subName:='3';
  251.           subrecords[8].commandKey:='3';
  252.           subrecords[9].subName:='2';
  253.           subrecords[9].commandKey:='2';
  254.           subrecords[10].subName:='1';
  255.           subrecords[10].commandKey:='1';
  256.           subrecords[11].subName:='0';
  257.           subrecords[11].commandKey:='0';
  258.         END;
  259.       END;
  260.       WITH tasMenu[2] DO
  261.         mname:='Umwandlung';
  262.         anzahlItems:=3;
  263.         WITH mItems[0] DO
  264.           iname:='Convert';
  265.           commandKey:='C';
  266.           anzahlSubitems:=0;
  267.         END;
  268.         FOR j:= 1 TO 2 DO
  269.           WITH mItems[j] DO
  270.             anzahlSubitems:=12;
  271.             FOR i:= 0 TO 11 DO
  272.               subrecords[i].commandKey:=0C
  273.             END;
  274.             subrecords[0].subName:='16';
  275.             subrecords[1].subName:='14';
  276.             subrecords[2].subName:='12';
  277.             subrecords[3].subName:='10';
  278.             subrecords[4].subName:='9';
  279.             subrecords[5].subName:='8';
  280.             subrecords[6].subName:='7';
  281.             subrecords[7].subName:='6';
  282.             subrecords[8].subName:='5';
  283.             subrecords[9].subName:='4';
  284.             subrecords[10].subName:='3';
  285.             subrecords[11].subName:='2';
  286.           END;
  287.         END;
  288.         mItems[1].iname:='Alte Basis';
  289.         mItems[2].iname:='Neue Basis';
  290.       END;
  291.       WITH tasMenu[3] DO
  292.         mname:='Statistik';
  293.         anzahlItems:=8;
  294.         WITH mItems[0] DO
  295.           iname:='Datenzahl';
  296.           commandKey:='i';
  297.           anzahlSubitems:=0;
  298.         END;
  299.         WITH mItems[1] DO
  300.           iname:='Summe der Eingaben';
  301.           commandKey:='=';
  302.           anzahlSubitems:=0;
  303.         END;
  304.         WITH mItems[2] DO
  305.           iname:='Summe der Quadrate';
  306.           commandKey:='U';
  307.           anzahlSubitems:=0;
  308.         END;
  309.         WITH mItems[3] DO
  310.           iname:='Standardabweichung';
  311.           commandKey:='T';
  312.           anzahlSubitems:=0;
  313.         END;
  314.         WITH mItems[4] DO
  315.           iname:='Grundgesamtheitsabw.';
  316.           commandKey:='V';
  317.           anzahlSubitems:=0;
  318.         END;
  319.         WITH mItems[5] DO
  320.           iname:='Mittelwert';
  321.           commandKey:='M';
  322.           anzahlSubitems:=0;
  323.         END;
  324.         WITH mItems[6] DO
  325.           iname:='Wert löschen';
  326.           commandKey:='D';
  327.           anzahlSubitems:=0;
  328.         END;
  329.         WITH mItems[7] DO
  330.           iname:='Reset';
  331.           commandKey:='R';
  332.           anzahlSubitems:=0;
  333.         END;
  334.       END;
  335.       InitMenu(tasMenu,firstMenu,rememberKey);
  336.       RETURN SetMenuStrip(wP,firstMenu);
  337.     END InitTasMenu;
  338.       
  339.     PROCEDURE WriteStr(str:ARRAY OF CHAR;to:SPDSet;newLine:BOOLEAN);
  340.       VAR
  341.         file:FileHandlePtr;
  342.         actuelLength:LONGINT;
  343.         cr:ARRAY [0..1] OF CHAR;
  344.         i:INTEGER;
  345.     BEGIN
  346.       IF s IN to THEN
  347.         WriteString(wP,str,newLine)
  348.       END;
  349.       IF p IN to THEN
  350.         cr[0]:=33C;
  351.         cr[1]:='E';
  352.         file:=Open(ADR('PRT:'),newFile);
  353.         IF file#NIL THEN
  354.           actuelLength:=Write(file,ADR(str),LONGINT(Length(str)));
  355.           IF newLine THEN
  356.             actuelLength:=Write(file,ADR(cr),2)
  357.           END;
  358.           Close(file)
  359.         END;
  360.       END;
  361.       IF d IN to THEN
  362.         FOR i:=0 TO INTEGER(Length(str))-1 DO
  363.           FileSystem.WriteChar(textFile,str[i])
  364.         END;
  365.         IF newLine THEN
  366.           FileSystem.WriteChar(textFile,lf)
  367.         END
  368.       END
  369.     END WriteStr;
  370.       
  371.     PROCEDURE WriteLong(x:LONGREAL;to:SPDSet);
  372.       VAR
  373.         str:ARRAY [0..22] OF CHAR;
  374.         expo,linksbuendig:[-1..1];
  375.     BEGIN
  376.       IF prSpace=nul THEN (* Zahl linksbuendig formatieren *)
  377.         linksbuendig:=-1
  378.       ELSE
  379.         linksbuendig:=1
  380.       END;
  381.       IF ((ABS(x) < 1.0) AND allFix) OR expoSet THEN 
  382.         expo:=-1;
  383.       ELSE
  384.         expo:=1;
  385.       END;
  386.       IF allFix THEN
  387.         RealToStr(x,str,outStellen*linksbuendig,(MaxStellen-1)*expo)
  388.       ELSE
  389.         RealToStr(x,str,MaxStellen*linksbuendig,outStellen*expo)
  390.       END;
  391.       IF (allFix AND (outStellen < 2)) THEN
  392.         WriteStr('Gesamtstellen zu klein',SPDSet{s},TRUE)
  393.       ELSE
  394.         WriteStr('=',to,FALSE);
  395.         WriteStr(str,to,TRUE)
  396.       END;
  397.     END WriteLong;
  398.     PROCEDURE RespondMessage;
  399.       VAR
  400.         msgPtr:IntuiMessagePtr;
  401.         class:IDCMPFlagSet;
  402.         code:CARDINAL;
  403.         menuNr,itemNr,subNr:CARDINAL;
  404.         ok:BOOLEAN;
  405.         string:ARRAY[0..22] OF CHAR;
  406.         fehlertext:ARRAY[0..81] OF CHAR;
  407.     
  408.       PROCEDURE Rechnen;
  409.         VAR
  410.           onlyFFP:BOOLEAN;
  411.           i:CARDINAL;
  412.           z:LONGREAL;
  413.           pos:INTEGER;
  414.           backup:FString;
  415.       BEGIN
  416.         IF formel[0]# 0C THEN
  417.           backup:=formel;
  418.           i:=0;
  419.           WHILE backup[i]#0C DO
  420.             IF (backup[i]='[') OR (backup[i]='{') THEN
  421.               backup[i]:='('
  422.             ELSIF (backup[i]=']') OR (backup[i]='}') THEN
  423.               backup[i]:=')'
  424.             END;
  425.             INC(i);
  426.           END;
  427.           fehler:=DefFormel(3,backup,TRUE,onlyFFP);
  428.           IF fehler#0 THEN
  429.             GetFehlertext(fehler,fehlertext);
  430.             WriteStr(fehlertext,SPDSet{s},TRUE);
  431.           ELSE
  432.             LongBerechnung(3,ergebnis,fehler);
  433.             IF formelAnwenden AND (fehler=0) THEN
  434.               IF AssignLong(formelChar,ergebnis) THEN END;
  435.               LongBerechnung(4,ergebnis,fehler)
  436.             END;
  437.             IF fehler = 0 THEN
  438.               IF AssignLong('m',ergebnis) THEN END;
  439.               summe:=summe+ergebnis;
  440.               IF (ergebnis< 1.0E154) AND (qSumme#MaxLongReal) THEN
  441.                 qSumme:=qSumme+(ergebnis*ergebnis)
  442.               ELSE
  443.                 qSumme:=MaxLongReal
  444.               END;
  445.               INC(datenzahl);
  446.               canDelete:=TRUE;
  447.               IF NOT printOnlyResult THEN
  448.                 WriteStr(formel,outputSet-SPDSet{s},FALSE);
  449.               pos:=myPref.rightMargin-myPref.leftMargin-INTEGER(Length(formel));
  450.                 IF pos >= (outStellen+8) THEN
  451.                   pos:=pos-(outStellen+8);
  452.                   printerSpace[pos]:=0C;
  453.                   WriteStr(printerSpace,outputSet-SPDSet{s},FALSE);
  454.                   printerSpace[pos]:=prSpace;
  455.                 ELSE
  456.                   WriteStr('',outputSet-SPDSet{s},TRUE)
  457.                 END
  458.               END;
  459.               WriteLong(ergebnis,outputSet);
  460.             ELSE
  461.               canDelete:=FALSE;
  462.               GetFehlertext(fehler,fehlertext);
  463.               WriteStr(fehlertext,SPDSet{s},TRUE)
  464.             END;
  465.           END;
  466.         ELSE
  467.           WriteStr('',SPDSet{s},TRUE);
  468.         END;
  469.       END Rechnen;
  470.       PROCEDURE MenuReaction;
  471.         VAR
  472.           menuNr,itemNr,subNr:CARDINAL;
  473.           menuIPtr:MenuItemPtr;
  474.         PROCEDURE Convert;
  475.           VAR er,signed:BOOLEAN;
  476.           zahl:LONGINT;
  477.           str:ARRAY[0..30] OF CHAR;
  478.         BEGIN
  479.           signed:=TRUE;
  480.           IF formel[0]#0C THEN
  481.             StrToVal(formel,zahl,signed,oldBase,er);
  482.             IF NOT er THEN
  483.               ValToStr(zahl,TRUE,str,newBase,-SIZE(str),' ',er)
  484.             END
  485.           END;
  486.           IF er THEN
  487.             WriteStr('Convertierung nicht möglich',SPDSet{s},TRUE)
  488.           ELSE
  489.             WriteStr(formel,outputSet-SPDSet{s},FALSE);
  490.             WriteStr(' convertiert zu ',outputSet,FALSE);
  491.             WriteStr(str,outputSet,TRUE)
  492.           END
  493.         END Convert;
  494.         PROCEDURE LastFormel;
  495.         BEGIN
  496.           oldFormel:=TRUE;
  497.         END LastFormel;
  498.         PROCEDURE Store;
  499.           VAR c:ARRAY[0..0] OF CHAR;
  500.         BEGIN
  501.           WriteStr('Variable:',SPDSet{s},TRUE);
  502.           c[0]:=GetKey(wP);
  503.           IF inputOK AND AssignLong(c[0],ergebnis) THEN
  504.             mDefiniert:=mDefiniert OR (c[0]='m');
  505.             WriteStr(c,outputSet,FALSE);
  506.             WriteStr(' :',outputSet,FALSE);
  507.             WriteLong(ergebnis,outputSet)
  508.           END;
  509.           inputOK:=FALSE (*damit alte Formel nicht geloescht wird*)
  510.         END Store;
  511.       
  512.         PROCEDURE SetFillChar;
  513.           VAR i:[0..255];
  514.               str:ARRAY[0..4] OF CHAR;
  515.               c:CHAR;
  516.         BEGIN
  517.           WriteStr('Füllzeichen:',SPDSet{s},FALSE);
  518.           c:=GetKey(wP);
  519.           IF inputOK AND (c # nul) THEN
  520.             IF c= cr THEN 
  521.               prSpace:= nul;
  522.               fillChar:=' ';
  523.               str:='NULL';
  524.               WriteStr(str,SPDSet{s},FALSE);
  525.             ELSE
  526.               prSpace:=c;
  527.               fillChar:=c;
  528.               str[0]:=c;
  529.               str[1]:=0C;
  530.               WriteStr(str,SPDSet{s},FALSE);
  531.             END;
  532.             FOR i:=0 TO 254 DO
  533.               printerSpace[i]:=prSpace;
  534.             END;
  535.             inputOK:=FALSE (*damit alte Formel nicht geloescht wird*)
  536.           END;
  537.           WriteStr('',SPDSet{s},TRUE);
  538.         END SetFillChar;
  539.       
  540.         PROCEDURE FormelAnwenden(f:BOOLEAN);
  541.           VAR
  542.             onlyFFP:BOOLEAN; 
  543.             c:ARRAY[0..1] OF CHAR;
  544.             text:ARRAY[0..40] OF CHAR;
  545.             fehler:CARDINAL;
  546.             formel:FString;
  547.         BEGIN
  548.           IF f THEN
  549.             WriteStr('Variable der Formel:',SPDSet{s},FALSE);
  550.             c[0]:=GetKey(wP);
  551.             IF (c[0]#0C) AND inputOK THEN
  552.               c[1]:=0C;
  553.               WriteStr(c,SPDSet{s},TRUE);
  554.               formelChar:=c[0];
  555.               IF AssignLong(formelChar,ergebnis) THEN
  556.                 formel[0]:=0C;
  557.                 REPEAT
  558.                   ReadString(wP,'Anzuwendende Formel:',formel,20);
  559.                   IF inputOK AND (formel[0] # 0C) THEN
  560.                     fehler:=DefFormel(4,formel,TRUE,onlyFFP);
  561.                   END;
  562.                   IF fehler#0 THEN
  563.                     GetFehlertext(fehler,text);
  564.                     WriteStr(text,SPDSet{s},TRUE);
  565.                   END;
  566.                 UNTIL (formel[0]=0C) OR (fehler=0) OR NOT inputOK;
  567.                 IF fehler = 0 THEN
  568.                   formelAnwenden:=TRUE;
  569.                   WriteStr('Anwenden:',outputSet,FALSE);
  570.                   WriteStr(formel,outputSet,TRUE)
  571.                 END
  572.               END
  573.             END;
  574.             inputOK:=FALSE (*damit alte Formel nicht geloescht wird*)
  575.           ELSE
  576.             formelAnwenden:=FALSE;
  577.             WriteStr('Formel anwenden aus',outputSet,TRUE)
  578.           END
  579.         END FormelAnwenden;
  580.         
  581.         PROCEDURE Delete;
  582.         BEGIN
  583.           IF canDelete THEN
  584.             summe:=summe-ergebnis;
  585.             qSumme:=qSumme-(ergebnis*ergebnis);
  586.             DEC(datenzahl);
  587.             canDelete:=FALSE;
  588.             WriteStr('Letzter Wert gelöscht',outputSet,TRUE);
  589.           ELSE
  590.             WriteStr('Kann letztes Datum nich löschen',SPDSet{s},TRUE)
  591.           END;
  592.         END Delete;
  593.         PROCEDURE Main;
  594.         BEGIN
  595.           ende:=TRUE;
  596.           WriteStr('Ende',outputSet-SPDSet{s},TRUE);
  597.         END Main;
  598.       
  599.         PROCEDURE DiskOn(on:BOOLEAN);
  600.           VAR p:StrPtr;
  601.             pathOK:BOOLEAN;
  602.             f:FileSystem.File;
  603.         BEGIN
  604.           IF on THEN
  605.             REPEAT
  606.               ReadString(wP,'Pfad:',fileName,30);
  607.               IF inputOK AND (fileName[0]#0C) THEN
  608.                 FileSystem.Lookup(f,fileName,0,TRUE);
  609.                 (* nur pruefen ob fileName ein gueltiger Dos-Pfad
  610.                    danach testfile f wieder schliessen
  611.                 *)
  612.                 IF f.res = FileSystem.done THEN 
  613.                   FileSystem.Close(f);
  614.                   IF fileOpen THEN
  615.                     (* altes File Schliessen *)
  616.                     FileSystem.Close(textFile);
  617.                   END;
  618.                   FileSystem.Lookup(textFile,fileName,512,TRUE);
  619.                   Assert(textFile.res=FileSystem.done,ADR('Cannot Open File'));
  620.                   fileOpen:=TRUE;
  621.                   pathOK:=TRUE;
  622.                   outputSet:=outputSet+SPDSet{d};
  623.                   WriteStr('Disk-Protokoll an',outputSet,TRUE)
  624.                 ELSE
  625.                   pathOK:=FALSE;
  626.                   ResponseText(f.res,p);
  627.                   WriteStr(p^,SPDSet{s},TRUE)
  628.                 END
  629.               END
  630.             UNTIL (fileName[0]=0C) OR pathOK OR NOT inputOK;
  631.             inputOK:=FALSE (*damit alte Formel nicht geloescht wird*)
  632.           ELSE
  633.             outputSet:=outputSet-SPDSet{d};
  634.             WriteStr('Disk-Protokoll ende',outputSet,TRUE);
  635.             IF fileOpen THEN
  636.               FileSystem.Close(textFile);
  637.               fileOpen:=FALSE
  638.             END
  639.           END
  640.         END DiskOn;
  641.       
  642.         PROCEDURE Datenzahl;
  643.         BEGIN
  644.           WriteStr('Datenzahl         ',outputSet,FALSE);
  645.           WriteLong(LONGREAL(datenzahl),outputSet);
  646.         END Datenzahl;
  647.         PROCEDURE Summe;
  648.         BEGIN
  649.           WriteStr('Summe der Daten   ',outputSet,FALSE);
  650.           WriteLong(summe,outputSet);
  651.         END Summe;
  652.         PROCEDURE QSumme;
  653.         BEGIN
  654.           WriteStr('Quadratsumme      ',outputSet,FALSE);
  655.           WriteLong(qSumme,outputSet)
  656.         END QSumme;
  657.         PROCEDURE Standard;
  658.         BEGIN
  659.           IF (datenzahl > 1) AND (qSumme<MaxLongReal) THEN
  660.             standart:=qSumme-((summe*summe)/LONGREAL(datenzahl));
  661.             standart:=standart/LONGREAL(datenzahl-1);
  662.             standart:=sqrt(standart);
  663.             WriteStr('Standardabweichung',outputSet,FALSE);
  664.             WriteLong(standart,outputSet)
  665.           ELSE
  666.             WriteStr('Datenzahl zu klein',SPDSet{s},TRUE)
  667.           END;
  668.         END Standard;
  669.         PROCEDURE Grundgesamtheit;
  670.         BEGIN
  671.           IF (datenzahl>1) AND (qSumme<MaxLongReal) THEN
  672.             grundgesamt:=qSumme-((summe*summe)/LONGREAL(datenzahl));
  673.             grundgesamt:=grundgesamt/LONGREAL(datenzahl);
  674.             grundgesamt:=sqrt(grundgesamt);
  675.             WriteStr('Grundgesamtheits. ',outputSet,FALSE);
  676.             WriteLong(grundgesamt,outputSet)
  677.           ELSE
  678.             WriteStr('Datenzahl zu klein',SPDSet{s},TRUE)
  679.           END;
  680.         END Grundgesamtheit;
  681.         PROCEDURE Mittelwert;
  682.         BEGIN
  683.           IF datenzahl > 0 THEN
  684.             mittelwert:=summe/LONGREAL(datenzahl);
  685.             WriteStr('Arithm. Mittelwert',outputSet,FALSE);
  686.             WriteLong(mittelwert,outputSet)
  687.           ELSE
  688.             WriteStr('Keine Daten für Mittelwert',SPDSet{s},TRUE)
  689.           END
  690.         END Mittelwert;
  691.         PROCEDURE Reset;
  692.         BEGIN
  693.           summe:=0.0;
  694.           qSumme:=0.0;
  695.           standart:=0.0;
  696.           grundgesamt:=0.0;
  697.           datenzahl:=0;
  698.           mittelwert:=0.0;
  699.           canDelete:=FALSE;
  700.           WriteStr('Reset Statistik',outputSet,TRUE)
  701.         END Reset;
  702.       
  703.       BEGIN (*MenuReaction*)
  704.         IF class=IDCMPFlagSet{menuPick} THEN
  705.           WHILE code#menuNull DO
  706.             menuNr:=MenuNum(code);
  707.             itemNr:=ItemNum(code);
  708.             subNr:=SubNum(code);
  709.             CASE menuNr OF
  710.               0:CASE itemNr OF
  711.                   0:LastFormel|
  712.               1:Store|
  713.               2:SetFillChar|
  714.               3:Main
  715.                 END|
  716.               1:CASE itemNr OF
  717.               0:CASE subNr OF
  718.                   0:outputSet:=outputSet-SPDSet{p}|
  719.                   1:outputSet:=outputSet+SPDSet{p}|
  720.                 END|
  721.                   1:CASE subNr OF
  722.                       0:printOnlyResult:=FALSE|
  723.                   1:printOnlyResult:=TRUE|
  724.                 END|  
  725.               2:CASE subNr OF
  726.                       0:DiskOn(FALSE)|
  727.                   1:DiskOn(TRUE)|
  728.                 END|
  729.               3:expoSet:=(subNr=1)|
  730.                   (*CASE subNr OF
  731.                   0:expoSet:=FALSE|    
  732.                   1:expoSet:=TRUE
  733.                 END|
  734.                   *)
  735.                   4:CASE subNr OF
  736.                   0:unit:=rad|    
  737.                   1:unit:=deg|
  738.                       2:unit:=gon|
  739.                 END| 
  740.                   5:CASE subNr OF
  741.                   0:FormelAnwenden(FALSE)|    
  742.                   1:FormelAnwenden(TRUE)|
  743.                 END|
  744.                   6:allFix:=(subNr=0)|
  745.                   (*CASE subNr OF
  746.                   0:allFix:=TRUE|    
  747.                   1:allFix:=FALSE|
  748.                 END|
  749.                   *)
  750.               7:CASE subNr OF
  751.                       0:outStellen:=14|
  752.                   1:outStellen:=12|    
  753.                   2:outStellen:=10|
  754.                       3..11:outStellen:=11-subNr|
  755.                 END|
  756.                 END|
  757.               2:CASE itemNr OF
  758.               0:Convert|
  759.               1:CASE subNr OF
  760.                   0:oldBase:=16|    
  761.                   1:oldBase:=14|
  762.                       2:oldBase:=12|
  763.                       3..11:oldBase:=13-subNr|    
  764.                 END|
  765.                     2:CASE subNr OF
  766.                   0:newBase:=16|    
  767.                   1:newBase:=14|
  768.                       2:newBase:=12|
  769.                       3..11:newBase:=13-subNr|
  770.                 END|
  771.             END|    
  772.               3:CASE itemNr OF
  773.                   0:Datenzahl|
  774.               1:Summe|
  775.               2:QSumme|
  776.               3:Standard|
  777.                   4:Grundgesamtheit|
  778.               5:Mittelwert|
  779.               6:Delete|
  780.                   7:Reset|
  781.                 END|
  782.             END;  
  783.             menuIPtr:=ItemAddress(firstMenu,code);
  784.             code:=menuIPtr^.nextSelect;
  785.           END;
  786.         ELSIF class=IDCMPFlagSet{closeWindow} THEN
  787.           Main
  788.         ELSE
  789.           Error(ADR('MenuReaktion'),ADR('unknownMenuMsg'))
  790.         END;
  791.       END MenuReaction;
  792.     BEGIN
  793.       (*WaitPort(wP^.userPort); das uebernimmt ReadString *)
  794.       msgPtr:=GetMsg(wP^.userPort);
  795.       IF msgPtr # NIL THEN
  796.         class := msgPtr^.class;
  797.         code  := msgPtr^.code;
  798.         ReplyMsg (msgPtr);
  799.         MenuReaction
  800.       ELSE
  801.         Rechnen
  802.       END
  803.     END RespondMessage;
  804.   BEGIN
  805.     OpenNewWindow(wP,180,100,40,5,FlagSet{close,drag,depth},
  806.                   'R E C H N E R');
  807.     Assert(wP#NIL,ADR('Cannot Open Rechner'));
  808.     ModifyIDCMP(wP,wP^.idcmpFlags+IDCMPFlagSet{menuPick});
  809.     SetClear(wP,FALSE);
  810.     IF NOT GetLongValue('m',oldm) THEN
  811.       oldm:=MaxLongReal
  812.     END;
  813.     Init;
  814.     IF InitTasMenu() THEN
  815.       REPEAT
  816.         IF (fehler=0) AND inputOK AND (NOT oldFormel) THEN
  817.           Assign(alteFormel,formel);
  818.           formel[0]:=0C
  819.         END;
  820.         IF oldFormel THEN
  821.           Assign(formel,alteFormel);
  822.           oldFormel:=FALSE
  823.         END;
  824.         ReadString(wP,':',formel,39);
  825.         RespondMessage;
  826.       UNTIL ende;
  827.     ELSE
  828.       Error(ADR('InitTasMenu'),ADR('Error'))
  829.     END;
  830.     CleanupTas;
  831.   END Tas;
  832. BEGIN
  833.   TermProcedure(CleanupTas);
  834.   wP:=NIL;
  835. END Calcu.mod
  836.